{*
  Object Pascal simple disk drive manipulation routines
  @Author  Maciej Zagozda (1998-2008)
  @Licence Microsoft Reciprocal License (Ms-RL)
  @Website http://www.codeplex.com/intelitechdelphirtns/
  @version 2008/04/20 Added documentation support
  @version 2008/05/16 Added GetDiskReady function
}
unit DiskRoutines;

interface

uses
  Classes,
  Controls,
  Dialogs,
  ExtCtrls,
  Forms,
  Graphics,
  Messages,
  MMSystem,
  SysUtils,
  Windows;

  const

    KILO_BYTES = 1024;
    MEGA_BYTES = 1048576;
    GIGA_BYTES = 1073741824;

    strnAlphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';


function GetDiskAvailableSpace( strnVolume: AnsiString ): Longint;
function GetDiskReady(chrDriveLetter: Char): Boolean;
function GetDiskTotalSpace( strnVolume: AnsiString ): Longint;

function GetDiskFileNameLength( strnVolume: String ): DWord;
function GetDiskFileSystem( strnVolume: String ): String;
function GetDiskSerialNumber( strnVolume: String ): DWord;
function GetDiskSystemFlags( strnVolume: String ): DWord;
function GetDiskType( strnVolume: String ): Word;
function GetDiskVolumeName( strnVolume: String ): String;
function SetDiskVolumeName( strnVolume: String; strnLabel: String ): Boolean;

function CloseDiskTray( charVolume: Char ): Boolean;
function OpenDiskTray( charVolume: Char ): Boolean;

implementation

uses
  FolderRoutines,
  StringRoutines;

function GetDiskAvailableSpace( strnVolume: String ): Longint;
var
  charRootPathName: PChar;
  dwrdSectorsPerCluster: Dword;
  dwrdBytesPerSector: Dword;
  dwrdNumberOfFreeClusters: Dword;
  dwrdTotalNumberOfClusters: Dword;
begin

  strnVolume := AppendBackslash( strnVolume );
  charRootPathName := PChar( strnVolume );

  if Windows.GetDiskFreeSpace( charRootPathName, dwrdSectorsPerCluster, dwrdBytesPerSector, dwrdNumberOfFreeClusters, dwrdTotalNumberOfClusters ) then
  begin
    Result := Abs( dwrdNumberOfFreeClusters * dwrdBytesPerSector * dwrdSectorsPerCluster );
  end
  else
  begin
    Result := -1;
  end;//if
end;

{*
  Checks if a drive has got disk ready
  @param chrDriveLetter, drive letter, example "A"
  @return True if drive has got disk ready, False otherwise
*}

function GetDiskReady(chrDriveLetter: Char): Boolean;
var
  intErrorMode: Integer;
  fp           : TextFile;
begin
  try
    intErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
    try
      AssignFile(fp,strDriveLetter + ':\foo.bar');
      Reset(fp);
      CloseFile(fp);
    finally
      SetErrorMode(intErrorMode);
    end;
  except
    on E:EInOutError do
    begin
      if E.ErrorCode = 21 then Result := False;
    end;
  end;
end;

function GetDiskTotalSpace( strnVolume: AnsiString ): Longint;
var
  charRootPathName: PChar;
  dwrdSectorsPerCluster: Dword;
  dwrdBytesPerSector: Dword;
  dwrdNumberOfFreeClusters: Dword;
  dwrdTotalNumberOfClusters: Dword;
begin

  strnVolume := AppendBackslash( strnVolume );
  charRootPathName := PChar( strnVolume );

  if Windows.GetDiskFreeSpace( charRootPathName, dwrdSectorsPerCluster, dwrdBytesPerSector, dwrdNumberOfFreeClusters, dwrdTotalNumberOfClusters ) then
  begin
    Result := Abs( dwrdTotalNumberOfClusters * dwrdBytesPerSector * dwrdSectorsPerCluster );
  end
  else
  begin
    Result := -1;
  end;//if
end;

function GetDiskFileNameLength( strnVolume: AnsiString ): DWord;
var
  wordSerialNumber: DWord;
  wordFileNameLength: DWord;
  wordSystemFlags: DWord;
  charFileSystem: Array[0..12] Of Char;
  charVolume: Array[0..255] Of Char;
  charVolumeLabel: Array[0..12] Of Char;

  function TrimPath( strnString: AnsiString ): AnsiString;
  begin
    strnString := Trim( UpperCase( strnString ));

    If strnString = '' Then
    begin
      Result := '';
      Exit;
    end;//if

    If Length( strnString ) = 1 Then
    begin
      strnString := strnString + ':\';
    end;//if

    If Length( strnString ) > 1 Then
    begin
     If Copy( strnString, Length( strnString ), 1 ) <> '\' Then
     begin
       strnString := strnString + '\';
     end;//if

     Result := strnString;
    end;//if
  end;
begin
  strnVolume := TrimPath( strnVolume );
  StrPCopy( charVolume, strnVolume );

  GetVolumeInformation( charVolume, @charVolumeLabel, 12, @wordSerialNumber, wordFileNameLength, wordSystemFlags, @charFileSystem, 12 );

  Result := wordFileNameLength;
end;//function

function GetDiskFileSystem( strnVolume: String ): String;
var
  wordSerialNumber: DWord;
  wordFileNameLength: DWord;
  wordSystemFlags: DWord;
  charFileSystem: Array[0..12] Of Char;
  charVolume: Array[0..255] Of Char;
  charVolumeLabel: Array[0..12] Of Char;

  function TrimPath( strnString: AnsiString ): AnsiString;
  begin
    strnString := Trim( UpperCase( strnString ));

    If strnString = '' Then
    begin
      Result := '';
      Exit;
    end;//if

    If Length( strnString ) = 1 Then
    begin
      strnString := strnString + ':\';
    end;//if

    If Length( strnString ) > 1 Then
    begin
     If Copy( strnString, Length( strnString ), 1 ) <> '\' Then
     begin
       strnString := strnString + '\';
     end;//if

     Result := strnString;
    end;//if
  end;

begin
  strnVolume := TrimPath( strnVolume );
  StrPCopy( charVolume, strnVolume );

  GetVolumeInformation( charVolume, @charVolumeLabel, 12, @wordSerialNumber, wordFileNameLength, wordSystemFlags, @charFileSystem, 12 );

  Result := StrPas( charFileSystem );
end;//function

{*
  Retrieves the serial number of a given hard disk
  @param strVolume - needs to be the root path of the volume to examine, for example: C:\
  @return textual representation of the drive's serial number
*}

function GetDiskSerialNumber( strVolume: AnsiString ): AnsiString;
var
  wrdSerialNumber: DWord;
  wrdFileNameLength: DWord;
  wrdSystemFlags: DWord;
  chrFileSystem: Array[0..12] Of Char;
  chrVolume: Array[0..255] Of Char;
  chrVolumeLabel: Array[0..12] Of Char;

  function TrimPath( strnString: AnsiString ): AnsiString;
  begin
    strnString := Trim( UpperCase( strnString ));

    If strnString = '' Then
    begin
      Result := '';
      Exit;
    end;//if

    If Length( strnString ) = 1 Then
    begin
      strnString := strnString + ':\';
    end;//if

    If Length( strnString ) > 1 Then
    begin
     If Copy( strnString, Length( strnString ), 1 ) <> '\' Then
     begin
       strnString := strnString + '\';
     end;//if

     Result := strnString;
    end;//if
  end;

begin
  strnVolume := TrimPath( strnVolume );
  StrPCopy( charVolume, strnVolume );

  GetVolumeInformation(PChar(strnVolume), nil, 0, @wordSerialNumber, wordFileNameLength, wordSystemFlags, nil, 0);
  Result := IntToHex(HiWord(wordSerialNumber), 4) + '-' + IntToHex(LoWord(wordSerialNumber), 4);

end;

function GetDiskSystemFlags( strnVolume: String ): DWord;
var
  wordSerialNumber: DWord;
  wordFileNameLength: DWord;
  wordSystemFlags: DWord;
  charFileSystem: Array[0..12] Of Char;
  charVolume: Array[0..255] Of Char;
  charVolumeLabel: Array[0..12] Of Char;

  function TrimPath( strnString: AnsiString ): AnsiString;
  begin
    strnString := Trim( UpperCase( strnString ));

    If strnString = '' Then
    begin
      Result := '';
      Exit;
    end;//if

    If Length( strnString ) = 1 Then
    begin
      strnString := strnString + ':\';
    end;//if

    If Length( strnString ) > 1 Then
    begin
     If Copy( strnString, Length( strnString ), 1 ) <> '\' Then
     begin
       strnString := strnString + '\';
     end;//if

     Result := strnString;
    end;//if
  end;


begin
  strnVolume := TrimPath( strnVolume );
  StrPCopy( charVolume, strnVolume );

  GetVolumeInformation( charVolume, @charVolumeLabel, 12, @wordSerialNumber, wordFileNameLength, wordSystemFlags, @charFileSystem, 12 );

  Result := wordSystemFlags;
end;//function

function GetDiskType( strnVolume: String ): Word;
var
  charVolume: array[0..255] Of Char;

  function TrimPath( strnString: AnsiString ): AnsiString;
  begin
    strnString := Trim( UpperCase( strnString ));

    If strnString = '' Then
    begin
      Result := '';
      Exit;
    end;//if

    If Length( strnString ) = 1 Then
    begin
      strnString := strnString + ':\';
    end;//if

    If Length( strnString ) > 1 Then
    begin
     If Copy( strnString, Length( strnString ), 1 ) <> '\' Then
     begin
       strnString := strnString + '\';
     end;//if

     Result := strnString;
    end;//if
  end;

begin
  StrPCopy( charVolume, TrimPath( strnVolume ));
  Result := GetDriveType( charVolume );
end;//function

function GetDiskVolumeName( strnVolume: String ): String;
var
  wordSerialNumber: DWord;
  wordFileNameLength: DWord;
  wordSystemFlags: DWord;
  charFileSystem: Array[0..12] Of Char;
  charVolume: Array[0..255] Of Char;
  charVolumeLabel: Array[0..12] Of Char;

  function TrimPath( strnString: AnsiString ): AnsiString;
  begin
    strnString := Trim( UpperCase( strnString ));

    If strnString = '' Then
    begin
      Result := '';
      Exit;
    end;//if

    If Length( strnString ) = 1 Then
    begin
      strnString := strnString + ':\';
    end;//if

    If Length( strnString ) > 1 Then
    begin
     If Copy( strnString, Length( strnString ), 1 ) <> '\' Then
     begin
       strnString := strnString + '\';
     end;//if

     Result := strnString;
    end;//if
  end;
begin
  strnVolume := TrimPath( strnVolume );
  StrPCopy( charVolume, strnVolume );

  GetVolumeInformation( charVolume, @charVolumeLabel, 12, @wordSerialNumber, wordFileNameLength, wordSystemFlags, @charFileSystem, 12 );

  Result := StrPas( charVolumeLabel );
end;//function

function SetDiskVolumeName( strnVolume: String; strnLabel: String): Boolean;
var
  charVolume: Array[0..255] Of Char;
  charLabel: Array[0..255] Of Char;

  function TrimPath( strnString: AnsiString ): AnsiString;
  begin
    strnString := Trim( UpperCase( strnString ));

    If strnString = '' Then
    begin
      Result := '';
      Exit;
    end;//if

    If Length( strnString ) = 1 Then
    begin
      strnString := strnString + ':\';
    end;//if

    If Length( strnString ) > 1 Then
    begin
     If Copy( strnString, Length( strnString ), 1 ) <> '\' Then
     begin
       strnString := strnString + '\';
     end;//if

     Result := strnString;
    end;//if
  end;
begin
  strnVolume := TrimPath( strnVolume );
  StrPCopy( charVolume, strnVolume );
  StrPCopy( charLabel, strnLabel );

  Result := SetVolumeLabel( charVolume , charLabel );
end;//function


//_____________________________________________________________________________

function CloseDiskTray( charVolume: Char): Boolean;
var
  mcieResult: MciError;
  mcipParameter: TMCI_Open_Parms;
  wordFlags: DWord;
  strnA: String;
  wordA: Word;
begin

  Result := False;

  strnA := charVolume + ':';
  wordFlags := mci_Open_Type or mci_Open_Element;
  with mcipParameter do begin
    dwCallback := 0;
    lpstrDeviceType := 'CDAudio';
    lpstrElementName := PChar( strnA );
  end;//with

  mcieResult := mciSendCommand( 0, mci_Open, wordFlags, Longint( @mcipParameter ));
  if mcieResult <> 0 then exit;

  wordA := mcipParameter.wDeviceID;
  try
    mcieResult := mciSendCommand( wordA, MCI_SET, MCI_SET_DOOR_CLOSED, 0 );
    if mcieResult = 0 then exit;
    Result := True;
  finally
    mciSendCommand( wordA, mci_Close, wordFlags, Longint( @mcipParameter ));
  end;
end;

//_____________________________________________________________________________


function OpenDiskTray( charVolume: Char): Boolean;
var
  mcieResult: MciError;
  mcipParameter: TMCI_Open_Parms;
  wordFlags: DWord;
  strnA: String;
  wordA: Word;
begin

  Result := False;

  strnA := charVolume + ':';
  wordFlags := mci_Open_Type or mci_Open_Element;
  with mcipParameter do begin
    dwCallback := 0;
    lpstrDeviceType := 'CDAudio';
    lpstrElementName := PChar( strnA );
  end;//with

  mcieResult := mciSendCommand( 0, mci_Open, wordFlags, Longint( @mcipParameter ));
  if mcieResult <> 0 then exit;

  wordA := mcipParameter.wDeviceID;
  try
    mcieResult := mciSendCommand( wordA, MCI_SET, MCI_SET_DOOR_OPEN, 0 );
    if mcieResult = 0 then exit;
    Result := True;
  finally
    mciSendCommand( wordA, mci_Close, wordFlags, Longint( @mcipParameter ));
  end;
end;

end.
